home *** CD-ROM | disk | FTP | other *** search
/ Magnum One / Magnum One (Mid-American Digital) (Disc Manufacturing).iso / d18 / opbonus.arc / FBROWSE.ARC / FBDMAIN.IN1 < prev    next >
Text File  |  1991-03-20  |  12KB  |  419 lines
  1. {*********************************************************}
  2. {*                   FBDMAIN.IN1 5.06                    *}
  3. {*     Copyright (c) Enz EDV Beratung GmbH 1986-89.      *}
  4. {*                 All rights reserved.                  *}
  5. {*          Modified and used under license by           *}
  6. {*                 TurboPower Software.                  *}
  7. {*********************************************************}
  8.  
  9.   function IsLockError : Boolean;
  10.     {-Return true for a locking error}
  11.   begin
  12.     IsLockError := (IsamErrorClass = 2);
  13.   end;
  14.  
  15.   function Extend(S : String; Len : Byte) : String;
  16.     {-Pad or truncate string to specified length}
  17.   var
  18.     SLen : Byte absolute S;
  19.   begin
  20.     if SLen >= Len then begin
  21.       SLen := Len;
  22.       Extend := S;
  23.     end
  24.     else
  25.       Extend := Pad(S, Len);
  26.   end;
  27.  
  28.   procedure WriteHeader(Prompt : String; ShowFilter : Boolean);
  29.     {-Write header and bottom divider}
  30.   const
  31.     FilterOn : array[Boolean] of string[8] = ('        ', '«Filter»');
  32.   var
  33.     S : String;
  34.     I, J, L : Integer;
  35.     {$IFDEF UseMouse}
  36.     SaveMouse : Boolean;
  37.     {$ENDIF}
  38.   begin
  39.     {$IFDEF UseMouse}
  40.     HideMousePrim(SaveMouse);
  41.     {$ENDIF}
  42.  
  43.     {draw header}
  44.     S := Header;
  45.     L := Length(Prompt);
  46.     if L > ScreenWidth then
  47.       L := ScreenWidth;
  48.     J := 40-(L shr 1);
  49.     for I := 1 to L do
  50.       S[J+I] := Prompt[I];
  51.     FastWrite(S, 1, 1, HeadFootAttr);
  52.  
  53.     {indicate whether filtering is enabled}
  54.     if ShowFilter then
  55.       FastWrite(FilterOn[VB.IsFilteringEnabled], 1, 50, HeadFootAttr);
  56.  
  57.     {display active key}
  58.     if ActKeyNr = 1 then
  59.       S := ' Key: Last Name '
  60.     else
  61.       S := ' Key: Zip Code ';
  62.     FastWrite(S, 1, 62, HeadFootAttr);
  63.  
  64.     {$IFDEF UseMouse}
  65.     ShowMousePrim(SaveMouse);
  66.     {$ENDIF}
  67.   end;
  68.  
  69.   procedure WriteFooter(Prompt : String);
  70.     {-Write a footer on the menu line}
  71.   {$IFDEF UseMouse}
  72.   var
  73.     SaveMouse : Boolean;
  74.   {$ENDIF}
  75.   begin
  76.     {$IFDEF UseMouse}
  77.     HideMousePrim(SaveMouse);
  78.     {$ENDIF}
  79.  
  80.     FastWrite(Extend(Prompt, ScreenWidth), ScreenHeight, 1, HeadFootAttr);
  81.     GotoXYabs(Length(Prompt)+2, ScreenHeight);
  82.  
  83.     {$IFDEF UseMouse}
  84.     ShowMousePrim(SaveMouse);
  85.     {$ENDIF}
  86.   end;
  87.  
  88.   function Menu(Selection, Prompt : String) : Char;
  89.     {-Draw a bar menu and get a selection in the CharSet}
  90.   var
  91.     ChWord : Word;
  92.     Ch  : Char absolute ChWord;
  93.     CursorSL, CursorXY : Word;
  94.   begin
  95.     {save the cursor position and shape}
  96.     GetCursorState(CursorXY, CursorSL);
  97.     NormalCursor;
  98.  
  99.     {display prompt}
  100.     WriteFooter(Prompt);
  101.  
  102.     {flush keyboard buffer}
  103.     while KeyPressed do
  104.       Ch := ReadKey;
  105.  
  106.     {wait for valid key}
  107.     repeat
  108.       ChWord := ReadKeyWord;
  109.       Ch := Upcase(Ch);
  110.     until Pos(Ch, Selection) <> 0;
  111.  
  112.     {Restore cursor position and shape}
  113.     RestoreCursorState(CursorXY, CursorSL);
  114.  
  115.     {clear prompt line}
  116.     WriteFooter('');
  117.  
  118.     Menu := Ch;
  119.   end;
  120.  
  121.   procedure DispMessage(Prompt : String; WaitKey, SoundBell : Boolean);
  122.     {-Display a message on the menu line, optionally waiting for keystroke and
  123.       ringing bell}
  124.   var
  125.     C  : Word;
  126.   begin
  127.     if WaitKey then begin
  128.       if Prompt[Length(Prompt)] <> '.' then
  129.         Prompt := Prompt+'.';
  130.       WriteFooter(' '+Prompt+' Press any key...');
  131.       if SoundBell then
  132.         RingBell;
  133.       C := ReadKeyWord;
  134.     end
  135.     else
  136.       WriteFooter(' '+Prompt);
  137.   end;
  138.  
  139.   procedure DispMessageTemp(Prompt : String; Time : Word);
  140.     {-Display a timed message}
  141.   begin
  142.     WriteFooter(Prompt);
  143.     Delay(Time);
  144.     WriteFooter('');
  145.   end;
  146.  
  147.   procedure IsamErrorNum(F : Integer);
  148.     {-Display Isam error number and wait for key}
  149.   begin
  150.     DispMessage('IsamError: '+Long2Str(F), True, True);
  151.   end;
  152.  
  153.   function YesNo(Prompt : String; Default : Char) : Boolean;
  154.     {-Display Yes/No prompt}
  155.   var
  156.     Ch : Char;
  157.   begin
  158.     Ch := Menu('YN'^M, Prompt+' ['+Default+']');
  159.     if Ch = ^M then
  160.       Ch := Default;
  161.     YesNo := (Ch = 'Y');
  162.   end;
  163.  
  164.   function LockAbort : Boolean;
  165.     {-If a file lock prevents progress, ask whether to try again}
  166.   begin
  167.     LockAbort := False;
  168.     Locked := IsLockError;
  169.     if not Locked then
  170.       Exit;
  171.     LockAbort := not YesNo('A lock prevents access. Try again?', 'Y');
  172.   end;
  173.  
  174.   procedure AbortPrintMessage;
  175.     {-Display this message while printing}
  176.   begin
  177.     WriteFooter('Press any key to abort print ');
  178.   end;
  179.  
  180.   function Aborting : Boolean;
  181.     {-Check for a keypress during printing, and offer a chance to quit}
  182.   var
  183.     C  : Char;
  184.   begin
  185.     Aborting := False;
  186.     if KeyPressed then begin
  187.       repeat
  188.         C := ReadKey;
  189.       until not KeyPressed;
  190.       if YesNo('Do you really wish to quit?', 'N') then
  191.         Aborting := True
  192.       else
  193.         AbortPrintMessage;
  194.     end;
  195.   end;
  196.  
  197.   procedure Abort;
  198.     {-Abort the program with an out-of-memory error message}
  199.   begin
  200.     DispMessage(emInsufficientMemory, True, True);
  201.     NormalCursor;
  202.     ClrScr;
  203.     Halt(1);
  204.   end;
  205.  
  206.  
  207. {$IFDEF Novell}
  208.   {$F+}
  209.   function SemaphoreRefresh(FBP : FBrowserPtr) : Boolean;
  210.   var
  211.     Ticks : LongInt absolute $40:$6C;
  212.     T : LongInt;
  213.   begin
  214.     {assume false}
  215.     SemaphoreRefresh := False;
  216.  
  217.     with FBP^ do
  218.       {do nothing if this is a single-user fileblock}
  219.       if LongFlagIsSet(fbOptions, fbIsNet) then begin
  220.         {save tick count}
  221.         T := Ticks;
  222.  
  223.         {loop while key not pressed}
  224.         while not cwCmdPtr^.cpKeyPressed do
  225.           {is it time to check again?}
  226.           if (Ticks-T) >= RefreshPeriod then
  227.             {check to see if page stack has been invalidated}
  228.             if Sync.IsDirty(GetKeyNumber) then begin
  229.               {we need to refresh the display}
  230.               SemaphoreRefresh := True;
  231.               Exit;
  232.             end
  233.             else
  234.               {save the current tick count}
  235.               T := Ticks;
  236.       end;
  237.   end;
  238.   {$F-}
  239. {$ENDIF}
  240.  
  241. {$IFDEF UseAdjustableWindows}
  242. const
  243.   Step = 1;
  244.  
  245.   procedure MoveBrowseWindow;
  246.     {-Move the browse window interactively}
  247.   var
  248.     Finished : Boolean;
  249.   begin
  250.     if VB.IsZoomed then
  251.       Exit;
  252.     WriteFooter(' Use cursor keys to move, <Enter> to accept');
  253.     Finished := False;
  254.     with VB do
  255.       repeat
  256.         case ReadKeyWord of
  257.           $4700 : MoveWindow(-Step, -Step); {Home}
  258.           $4800 : MoveWindow(0, -Step);     {Up arrow}
  259.           $4900 : MoveWindow(Step, -Step);  {PgUp}
  260.           $4B00 : MoveWindow(-Step, 0);     {Left Arrow}
  261.           $4D00 : MoveWindow(Step, 0);      {Right Arrow}
  262.           $4F00 : MoveWindow(-Step, Step);  {End}
  263.           $5000 : MoveWindow(0, Step);      {Down arrow}
  264.           $5100 : MoveWindow(Step, Step);   {PgDn}
  265.           $1C0D : Finished := True;         {Enter}
  266.         end;
  267.  
  268.         if ClassifyError(GetLastError) = etFatal then
  269.           Abort;
  270.       until Finished;
  271.  
  272.     WriteFooter('');
  273.   end;
  274.  
  275.   procedure ResizeBrowseWindow;
  276.     {-Resize the browse window interactively}
  277.   var
  278.     Finished : Boolean;
  279.   begin
  280.     if VB.IsZoomed then
  281.       Exit;
  282.     WriteFooter(' Use cursor keys to resize, <Enter> to accept');
  283.     Finished := False;
  284.     with VB do
  285.       repeat
  286.         case ReadKeyWord of
  287.           $4700 : ResizeWindow(-Step, -Step); {Home}
  288.           $4800 : ResizeWindow(0, -Step);     {Up}
  289.           $4900 : ResizeWindow(Step, -Step);  {PgUp}
  290.           $4B00 : ResizeWindow(-Step, 0);     {Left}
  291.           $4D00 : ResizeWindow(Step, 0);      {Right}
  292.           $4F00 : ResizeWindow(-Step, Step);  {End}
  293.           $5000 : ResizeWindow(0, Step);      {Down}
  294.           $5100 : ResizeWindow(Step, Step);   {PgDn}
  295.           $1C0D : Finished := True;           {Enter}
  296.         end;
  297.  
  298.         if ClassifyError(GetLastError) = etFatal then
  299.           Abort;
  300.       until Finished;
  301.  
  302.     WriteFooter('');
  303.   end;
  304.  
  305.   procedure ToggleZoom;
  306.     {-Toggle zoom status of the browse window}
  307.   begin
  308.     with VB do begin
  309.       if IsZoomed then
  310.         Unzoom
  311.       else
  312.         Zoom;
  313.  
  314.       if ClassifyError(GetLastError) = etFatal then
  315.         Abort;
  316.     end;
  317.   end;
  318. {$ENDIF}
  319.  
  320. {$F+}
  321.   function ValidateState(EFP : EntryFieldPtr; var Err : Word;
  322.                          var ErrSt : StringPtr) : Boolean;
  323.     {-Validate a state entry}
  324.   const
  325.     StateStrings   : array[1..51] of array[1..2] of Char = (
  326.       'AK', 'AL', 'AR', 'AZ', 'CA', 'CO', 'CT', 'DC', 'DE', 'FL', 'GA', 'HI',
  327.       'IA', 'ID', 'IL', 'IN', 'KS', 'KY', 'LA', 'MA', 'MD', 'ME', 'MI', 'MN',
  328.       'MO', 'MS', 'MT', 'NC', 'ND', 'NE', 'NH', 'NJ', 'NM', 'NV', 'NY', 'OH',
  329.       'OK', 'OR', 'PA', 'RI', 'SC', 'SD', 'TN', 'TX', 'UT', 'VA', 'VT', 'WA',
  330.       'WI', 'WV', 'WY');
  331.     BadState : String[36] = 'Not a valid abbreviation for a state';
  332.   var
  333.     I  : Word;
  334.     S  : String[2];
  335.   begin
  336.     ValidateState := True;
  337.  
  338.     S := Trim(EFP^.efEditSt^);
  339.     if not ValidationOff then
  340.       case Length(S) of
  341.         1 :                  {no 1-character abbreviations}
  342.           begin
  343.             Err := ecPartialEntry;    {standard error code}
  344.             ErrSt := @emPartialEntry; {standard error message}
  345.             ValidateState := False;
  346.           end;
  347.         2 :                  {check list of valid abbreviations}
  348.           begin
  349.             for I := 1 to 51 do
  350.               if S = StateStrings[I] then
  351.                 Exit;
  352.             Err := 1; {arbitrary}
  353.             ErrSt := @BadState;
  354.             ValidateState := False;
  355.           end;
  356.       end;
  357.   end;
  358.  
  359.   function ValidatePhone(EFP : EntryFieldPtr; var Err : Word;
  360.                          var ErrSt : StringPtr) : Boolean;
  361.     {-Validate a phone number}
  362.   begin
  363.     if ValidationOff then
  364.       ValidatePhone := True
  365.     else
  366.       ValidatePhone := ValidateSubfields(ValidPhone, EFP, Err, ErrSt);
  367.   end;
  368.  
  369.   function ValidateZip(EFP : EntryFieldPtr; var Err : Word;
  370.                        var ErrSt : StringPtr) : Boolean;
  371.     {-Validate a zip code}
  372.   begin
  373.     if ValidationOff then
  374.       ValidateZip := True
  375.     else
  376.       ValidateZip := ValidateSubfields(ValidZip, EFP, Err, ErrSt);
  377.   end;
  378.  
  379.   procedure PhoneZipConversion(EFP : EntryFieldPtr; PostEdit : Boolean);
  380.     {-Conversion routine for phone numbers and zip codes.}
  381.     {-Special note: This special conversion routine is needed to meet the
  382.       demands of the Search routine, which allows searches based on partial
  383.       zip codes and phone numbers. The ValidationOff flag used in the three
  384.       validation routines shown above is needed for the same reason.}
  385.   var
  386.     S : String[20];
  387.     SLen : Byte absolute S;
  388.     AllDone : Boolean;
  389.   begin
  390.     with EFP^ do
  391.       if PostEdit then begin
  392.         S := efEditSt^;
  393.         AllDone := False;
  394.         repeat
  395.           {trim trailing blanks and hyphens}
  396.           case S[SLen] of
  397.             ' ', '-' :
  398.               Dec(SLen);
  399.             else
  400.               AllDone := True;
  401.           end;
  402.         until AllDone;
  403.         String(efVarPtr^) := S;
  404.       end
  405.       else begin
  406.         {is string too long? if so, truncate it}
  407.         if Byte(efVarPtr^) > efMaxLen then
  408.           Byte(efVarPtr^) := efMaxLen;
  409.  
  410.         {initialize the edit string}
  411.         efEditSt^ := String(efVarPtr^);
  412.  
  413.         {merge picture mask characters if necessary}
  414.         if Length(efEditSt^) < efMaxLen then
  415.           MergePicture(efEditSt^, efEditSt^);
  416.       end;
  417.   end;
  418. {$F-}
  419.